home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / fortran / mslang / fort_bmp / bmpwrite.for < prev   
Text File  |  1993-07-14  |  10KB  |  244 lines
  1.       subroutine bmpwrite(filename,biBitCount,ncol,nrow,nclr,rgb,data,
  2.      $                    error)
  3.       implicit none
  4.  
  5. c****************************************************************************
  6. c*                                                                          *
  7. c*    (C) Copyright 1993 by Enlightened Solutions. All rights reserved.     *
  8. c*                                                                          *
  9. c*                         Enlightened Solutions                            *
  10. c*                         1503 Linda Rosa Avenue                           *
  11. c*                         Los Angeles, CA  90041-2210                      *
  12. c*                         Phone: 213-255-3932                              *
  13. c*                         CIS ID: 70704,3067                               *
  14. c*                                                                          *
  15. c*   This software is distributed free-of-charge, but is NOT released to    *
  16. c*   the public domain. If you make changes to the code, please do so on a  *
  17. c*   copy, and include the originals in any distribution, with copyright    *
  18. c*   notices intact.                                                        *
  19. c*                                                                          *
  20. c****************************************************************************
  21.  
  22. c    This subroutine writes a Windows Bitmap v3.0 graphic file. Note that
  23. c  "v3.0" does not refer to Windows 3.0, but rather Bitmap 3.0, which is 
  24. c  described in the file BMP30FMT.TXT. The files created by this routine are
  25. c  compatible with Windows 3.x. Compressed (RLE) bitmap formats are not
  26. c  supported. This subroutine has been compiled successfully under MS FORTRAN 
  27. c  v5.1 and MS Powerstation FORTRAN (32 bit), although the Powerstation
  28. c  compiler will issue a warning that the [huge] attribute of the "data"
  29. c  array will be ignored, which is ok.
  30.  
  31. c    The input arguments (and one output) are described below. The other
  32. c  bitmap header variables (as described in BMP30FMT.TXT) can remain set
  33. c  as they are for most work, but you could modify them if needed.
  34. c
  35. c  filename - Character*(*), input. Name of the bitmap file to be created,
  36. c             including path if necessary. If the file already exists, 
  37. c             "error" is set to .true., an informational message is 
  38. c             displayed, and control is returned to the calling program.
  39. c  biBitCount - Integer*2, input. The number of bits/pixel of the "data"
  40. c               array. Valid values are 1,4,8, and 24 (representing maximum 
  41. c               colors of 2,16,256, and 16.8 million, respectively).
  42. c  ncol - Integer*4, input. Number of pixels in the horizontal direction.
  43. c  nrow - Integer*4, input. Number of pixels in the vertical direction.
  44. c  nclr - Integer*4, input. Number of colors in palette.
  45. c  rgb - Byte(3,*), input. An array containing the red, green, and blue
  46. c        components of the color palette. The first color in the
  47. c        palette (corresponding to data with value=0) is specified by
  48. c        rgb(1,1), rgb(2,1), rgb(3,1), and so on through nclr colors.
  49. c        *EXCEPTION* It would be impractical to specify a 16.8 million color
  50. c        palette for a 24 bit image, therefore these images specify the colors
  51. c        directly by the data itself, i.e. the three bytes of data specify
  52. c        the red, green, and blue components of that particular pixel. In 
  53. c        this case, "rgb" and "nclr" are ignored.
  54. c  data - [huge]byte(*), input. An array containing the data for the bitmap. 
  55. c         "biBitCount" specifies how many bits/pixel. The array is one-dimen-
  56. c         sional here, but may be two (or more) dimensions in the calling 
  57. c         program. The only requirement is that the data be contiguous 
  58. c         starting at the first bit of the array. The first value of the
  59. c         array will correspond to the lower left pixel of the bitmap image.
  60. c  error - Logical*4, output. If an error occurred, this variable will be
  61. c          set to .true., an informational message will be displayed, and  
  62. c          control will be returned to the calling program.
  63.  
  64. c  Bitmap File-Header variables. See "BMP30FMT.TXT" for more info.
  65.       
  66.       character*2 bfType
  67.       integer*4 bfSize,bfOffBits
  68.       integer*2 bfReserved1,bfReserved2
  69.  
  70. c  Bitmap Info-Header variables. See "BMP30FMT.TXT" for more info.
  71.       
  72.       integer*2 biPlanes,biBitCount
  73.       integer*4 biSize,biWidth,biHeight,biCompression,biSizeImage
  74.       integer*4 biXPelsPerMeter,biYPelsPerMeter,biClrUsed,biClrImportant
  75.  
  76. c  RGBQuad variables. See "BMP30FMT.TXT" for more info.
  77.       
  78.       byte rgb(3,*),rgbReserved
  79.       
  80. c  Other passed and local variables.
  81.  
  82.       byte data[huge](*),buffer(4)
  83.       integer*2 getlen,nbuf
  84.       integer*4 ncol_bytes,ncol,nrow,nclr,ioerr,iu,i,j,j0
  85.       logical*4 error,open,exist
  86.       character*(*) filename
  87.       data buffer /4*0/
  88. c---------------------------------------------------------------------------
  89.  
  90.       error = .false.
  91.  
  92. c  Perform initial validity tests on formal arguments.
  93.  
  94. c  Check for some non-sensical values of ncol and nrow.
  95.       
  96.       if(ncol.le.0 .or. nrow.le.0)  then
  97.        write(*,122)  ncol,nrow
  98. 122    format(/,' BMPWRITE - Ncol and nrow must be > 0.',/,
  99.      $          '            Ncol = ',i8,/,
  100.      $          '            Nrow = ',i8,/)
  101.        error = .true.
  102.        return
  103.       endif
  104.  
  105. c  Ensure biBitCount is valid.
  106.  
  107.       if(biBitCount.ne.1 .and. biBitCount.ne.4 .and.
  108.      $   biBitCount.ne.8 .and. biBitCount.ne.24)  then
  109.        write(*,222)  biBitCount
  110. 222    format(/,' BMPWRITE - biBitCount must be 1,4,8, or 24.',/,
  111.      $          '            biBitCount = ',i8,/)
  112.        error = .true.
  113.        return
  114.       endif
  115.       
  116. c  Ensure nclr is not too big, warn if too small. If 24 bit data, then
  117. c  nclr is ignored.
  118.  
  119.       if(biBitCount.ne.24)  then
  120.        if(nclr.gt.2**biBitCount)  then
  121.         write(*,322)  nclr,biBitCount,2**biBitCount
  122. 322     format(/,' BMPWRITE - Number of colors (nclr) too big for',/,
  123.      $           '            bits/pixel (biBitCount) specified.',/,
  124.      $           '            Nclr = ',i8,/,
  125.      $           '            biBitCount = ',i8,/,
  126.      $           '            Max colors allowed = ',i8,/)
  127.         error = .true.       
  128.         return
  129.       
  130.        else if(nclr.lt.2**biBitCount)  then 
  131.         write(*,422)  biBitCount,nclr,2**biBitCount
  132. 422     format(/,' BMPWRITE - WARNING: Number of colors (nclr) is',/, 
  133.      $     '            LESS than capacity of',i3,' bits/pixel data.',/,
  134.      $           '            Nclr = ',i8,/,
  135.      $           '            Max colors allowed = ',i8,/,
  136.      $           '            Continuing.',/)
  137.        endif
  138.       endif
  139.       
  140. c  Make sure file doesn't already exist. 
  141.  
  142.       inquire(file=filename,exist=exist)
  143.       if(exist)  then
  144.        write(*,522)  filename(1:getlen(filename))
  145. 522    format(/,' BMPWRITE - ',a,' already exists.',/)
  146.        error = .true.
  147.        return
  148.       endif
  149.  
  150. c  Find available unit # and open file.
  151.       
  152.       iu = 0
  153.       open = .true.
  154.       do while(open)
  155.        iu = iu + 1
  156.        inquire(unit=iu,opened=open)
  157.       enddo  
  158.       open(iu,file=filename,status='new',form='binary',iostat=ioerr,
  159.      $     err=98)
  160.  
  161.       ncol_bytes = ncol*biBitCount/8
  162.       nbuf = mod(4 - mod(ncol_bytes,4),4)
  163.       bfType = 'BM'
  164.       if(biBitCount.ne.24)  then
  165.        bfSize = 54 + nclr*4 + (ncol_bytes + nbuf)*nrow
  166.        bfOffBits = 54 + nclr*4
  167.       else 
  168.        bfSize = 54 + (ncol_bytes + nbuf)*nrow
  169.        bfOffBits = 54
  170.       endif
  171.       bfReserved1 = 0
  172.       bfReserved2 = 0
  173.  
  174. c  Write BitmapFileHeader
  175.  
  176.       write(iu,iostat=ioerr,err=98)  bfType,bfSize,bfReserved1,
  177.      $                               bfReserved2,bfOffBits
  178.  
  179.       biSize = 40
  180.       biWidth = ncol
  181.       biHeight = nrow
  182.       biPlanes = 1
  183.       biCompression = 0
  184.       biSizeImage = (ncol_bytes + nbuf)*nrow
  185.       biXPelsPerMeter = 0
  186.       biYPelsPerMeter = 0
  187.       biClrUsed = 0
  188.       biClrImportant = 0
  189.  
  190. c  Write BitmapInfoHeader
  191.  
  192.       write(iu,iostat=ioerr,err=98)  biSize,biWidth,biHeight,biPlanes,
  193.      $                               biBitCount,biCompression,
  194.      $                               biSizeImage,biXPelsPerMeter,
  195.      $                               biYPelsPerMeter,biClrUsed,
  196.      $                               biClrImportant
  197.  
  198. c  Write color table. Note that for 24 bit images, each three data
  199. c  bytes represent the red, green, and blue components, respectively.
  200.  
  201.       if(biBitCount.ne.24)  then
  202.        rgbReserved = 0
  203.        write(iu,iostat=ioerr,err=98)  
  204.      $                     ((rgb(j,i),j=3,1,-1),rgbReserved,i=1,nclr)
  205.       endif
  206.  
  207. c  Write data. Note that the first pixel in array "data" will correspond
  208. c  to the lower left corner of the image.
  209. c  The different write statement for the nbuf.eq.0 case is only for
  210. c  speed reasons.
  211.  
  212.       if(nbuf.ne.0)  then
  213.        do 1 i = 1,nrow
  214.         j0 = (i - 1)*ncol_bytes + 1
  215.         write(iu,iostat=ioerr,err=98)  (data(j),j=j0,j0+ncol_bytes-1),
  216.      $                                 (buffer(j),j=1,nbuf)
  217. 1      continue
  218.       else
  219.        write(iu,iostat=ioerr,err=98)  (data(j),j=1,ncol_bytes*nrow)
  220.       endif
  221.       close(iu)
  222.       return
  223.  
  224. 98    error = .true.
  225.       write(*,622)  ioerr,filename(1:getlen(filename))
  226. 622   format(/,' BMPWRITE - Error # ',i5,' occurred while writing ',a,/)
  227.  
  228.       close(iu)
  229.       return
  230.       end
  231. c****************************************************************************      
  232.       integer*2 function getlen(word)
  233.       integer*2 ic
  234.       character*(*) word
  235.  
  236.       getlen = len(word) + 1
  237. 11    getlen = getlen - 1
  238.       if(getlen.eq.0)  return
  239.       ic = ichar(word(getlen:getlen))
  240.       if(ic.eq.32 .or. ic.eq.0)  go to 11
  241.  
  242.       return
  243.       end
  244.